home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Celestin Apprentice 7
/
Apprentice-Release7.iso
/
Environments
/
MacMETH 3.2.4
/
More Examples
/
Hennessy3.MOD
< prev
next >
Wrap
Text File
|
1996-06-20
|
11KB
|
537 lines
MODULE Hennessy3;
FROM Storage IMPORT ALLOCATE;
FROM SYSTEM IMPORT VAL, TSIZE;
FROM SYSTEM IMPORT REG, SETREG;
FROM InOut IMPORT WriteLn, WriteString, WriteInt, Read, OpenOutput, CloseOutput;
CONST
bubblebase = 1.61;
quickbase = 1.92;
treebase = 2.5;
puzzlebase = 0.5;
(* Puzzle *)
size = 511;
classmax = 3;
typemax = 12;
d = 8D;
(* Bubble, Quick *)
sortelements = 5000;
srtelements = 500;
TYPE
(* tree *)
node = POINTER TO nodeDesc;
nodeDesc = RECORD
left, right: node;
val: LONGINT;
END;
Proc = PROCEDURE;
VAR
fixed,floated: REAL; ch: CHAR;
(* global *)
seed: LONGINT;
(* tree *)
tree: node;
(* Puzzle *)
piececount: ARRAY [0..classmax] OF LONGINT;
class, piecemax: ARRAY [0..typemax] OF LONGINT;
puzzl: ARRAY [0..size] OF BOOLEAN;
p: ARRAY [0..typemax], [0..size] OF BOOLEAN;
n,
kount: LONGINT;
(* Bubble, Quick *)
sortlist: ARRAY [0..sortelements] OF LONGINT;
biggest, littlest,
top: LONGINT;
(* global procedures *)
PROCEDURE Getclock (): LONGINT;
TYPE P = POINTER TO LONGINT;
VAR ticks: P; tk: LONGINT;
BEGIN ticks := VAL(P, 16AH);
tk := ticks^; RETURN TRUNCD(FLOATD(tk) * (1000.0D0/60.0D0) + 0.5D0)
END Getclock;
PROCEDURE Initrand ();
BEGIN seed := 74755D
END Initrand;
PROCEDURE Rand (): LONGINT;
BEGIN
seed := (seed * 1309D + 13849D) MOD 65535D;
RETURN (seed);
END Rand;
(* A compute-bound program from Forest Baskett. *)
PROCEDURE Fit (i, j: LONGINT): BOOLEAN;
VAR k: LONGINT;
BEGIN k := 0;
WHILE k <= piecemax[i] DO
IF ( p[i][k] ) THEN IF ( puzzl[j+k] ) THEN RETURN FALSE END END;
INC(k)
END;
RETURN TRUE
END Fit;
PROCEDURE Place (i, j: LONGINT): LONGINT;
VAR k: LONGINT;
BEGIN k := 0;
WHILE k <= piecemax[i] DO
IF ( p[i][k] ) THEN puzzl[j+k] := TRUE END;
INC(k)
END;
piececount[class[i]] := piececount[class[i]] - 1D;
k := j;
WHILE k <= LONG(size) DO
IF ( ~ puzzl[k] ) THEN RETURN (k) END;
INC(k)
END ;
RETURN (0);
END Place;
PROCEDURE Remove (i, j: LONGINT);
VAR k: LONGINT;
BEGIN k := 0;
WHILE k <= piecemax[i] DO
IF ( p[i][k] ) THEN puzzl[j+k] := FALSE END;
INC(k)
END;
piececount[class[i]] := piececount[class[i]] + 1D
END Remove;
PROCEDURE Trial (j: LONGINT): BOOLEAN;
VAR i, k: LONGINT;
BEGIN i := 0;
kount := kount + 1D;
WHILE i <= LONG(typemax) DO
IF ( piececount[class[i]] # 0D) THEN
IF ( Fit (i, j) ) THEN
k := Place (i, j);
IF Trial(k) OR (k = 0D) THEN RETURN (TRUE)
ELSE Remove (i, j)
END;
END
END;
INC(i)
END;
RETURN (FALSE)
END Trial;
PROCEDURE Puzzle ();
VAR i, j, k, m: LONGINT;
BEGIN
m := 0D; WHILE m <= LONG(size) DO puzzl[m] := TRUE; INC(m) END ;
i := 1;
WHILE i <= 5D DO j := 1D;
WHILE j <= 5D DO k := 1D;
WHILE k <= 5D DO
puzzl[i+d*(j+d*k)] := FALSE; INC(k)
END;
INC(j)
END;
INC(i)
END;
i := 0D;
WHILE i <= LONG(typemax) DO m := 0;
WHILE m<= LONG(size) DO
p[i][m] := FALSE; INC(m)
END;
INC(i)
END;
i := 0D;
WHILE i <= 3D DO j := 0D;
WHILE j <= 1D DO k := 0D;
WHILE k <= 0D DO
p[0][i+d*(j+d*k)] := TRUE; INC(k)
END;
INC(j)
END;
INC(i)
END;
class[0] := 0D;
piecemax[0] := 3D+d*1D+d*d*0D;
i := 0D;
WHILE i <= 1D DO j := 0D;
WHILE j <= 0D DO k := 0D;
WHILE k <= 3D DO
p[1][i+d*(j+d*k)] := TRUE; INC(k)
END;
INC(j)
END;
INC(i)
END;
class[1] := 0D;
piecemax[1] := 1D+d*0D+d*d*3D;
i := 0D;
WHILE i <= 0D DO j := 0D;
WHILE j <= 3D DO k := 0D;
WHILE k <= 1D DO
p[2][i+d*(j+d*k)] := TRUE; INC(k)
END;
INC(j)
END;
INC(i)
END;
class[2] := 0D;
piecemax[2] := 0D+d*3D+d*d*1D;
i := 0D;
WHILE i <= 1D DO j := 0D;
WHILE j <= 3D DO k := 0D;
WHILE k <= 0D DO
p[3][i+d*(j+d*k)] := TRUE; INC(k)
END;
INC(j)
END;
INC(i)
END;
class[3] := 0D;
piecemax[3] := 1D+d*3D+d*d*0D;
i := 0D;
WHILE i <= 3D DO j := 0D;
WHILE j <= 0D DO k := 0D;
WHILE k <= 1D DO
p[4][i+d*(j+d*k)] := TRUE; INC(k)
END;
INC(j)
END;
INC(i)
END;
class[4] := 0D;
piecemax[4] := 3D+d*0D+d*d*1D;
i := 0D;
WHILE i <= 0D DO j := 0D;
WHILE j <= 1D DO k := 0D;
WHILE k <= 3D DO
p[5][i+d*(j+d*k)] := TRUE; INC(k)
END;
INC(j)
END;
INC(i)
END;
class[5] := 0D;
piecemax[5] := 0D+d*1D+d*d*3D;
i := 0D;
WHILE i <= 2D DO j := 0D;
WHILE j <= 0D DO k := 0D;
WHILE k <= 0D DO
p[6][i+d*(j+d*k)] := TRUE; INC(k)
END;
INC(j)
END;
INC(i)
END;
class[6] := 1D;
piecemax[6] := 2D+d*0D+d*d*0D;
i := 0D;
WHILE i <= 0D DO j := 0D;
WHILE j <= 2D DO k := 0D;
WHILE k <= 0D DO
p[7][i+d*(j+d*k)] := TRUE; INC(k)
END;
INC(j)
END;
INC(i)
END;
class[7] := 1D;
piecemax[7] := 0D+d*2D+d*d*0D;
i := 0D;
WHILE i <= 0D DO j := 0D;
WHILE j <= 0D DO k := 0D;
WHILE k <= 2D DO
p[8][i+d*(j+d*k)] := TRUE; INC(k)
END;
INC(j)
END;
INC(i)
END;
class[8] := 1D;
piecemax[8] := 0D+d*0D+d*d*2D;
i := 0D;
WHILE i <= 1D DO j := 0D;
WHILE j <= 1D DO k := 0D;
WHILE k <= 0D DO
p[9][i+d*(j+d*k)] := TRUE; INC(k)
END;
INC(j)
END;
INC(i)
END;
class[9] := 2D;
piecemax[9] := 1D+d*1D+d*d*0D;
i := 0D;
WHILE i <= 1D DO j := 0D;
WHILE j <= 0D DO k := 0D;
WHILE k <= 1D DO
p[10][i+d*(j+d*k)] := TRUE; INC(k)
END;
INC(j)
END;
INC(i)
END;
class[10] := 2D;
piecemax[10] := 1D+d*0D+d*d*1D;
i := 0D;
WHILE i <= 0D DO j := 0D;
WHILE j <= 1D DO k := 0D;
WHILE k <= 1D DO
p[11][i+d*(j+d*k)] := TRUE; INC(k)
END;
INC(j)
END;
INC(i)
END;
class[11] := 2D;
piecemax[11] := 0D+d*1D+d*d*1D;
i := 0D;
WHILE i <= 1D DO j := 0D;
WHILE j <= 1D DO k := 0D;
WHILE k <= 1D DO
p[12][i+d*(j+d*k)] := TRUE; INC(k)
END;
INC(j)
END;
INC(i)
END;
class[12] := 3D;
piecemax[12] := 1D+d*1D+d*d*1D;
piececount[0] := 13D;
piececount[1] := 3D;
piececount[2] := 1D;
piececount[3] := 1D;
m := 1D+d*(1D+d*1D);
kount := 0;
IF Fit(0, m) THEN n := Place(0, m)
ELSE WriteString("Error1 in Puzzle$")
END;
IF ~ Trial(n) THEN WriteString("Error2 in Puzzle.$")
ELSIF kount # 2005D THEN WriteString("Error3 in Puzzle.$")
END
END Puzzle;
(* Sorts an array using quicksort *)
PROCEDURE Initarr();
VAR i, temp: LONGINT;
BEGIN
Initrand();
biggest := 0; littlest := 0; i := 1D;
WHILE i <= LONG(sortelements) DO
temp := Rand();
sortlist[i] := temp - (temp DIV 100000D)*100000D - 50000D;
IF sortlist[i] > biggest THEN biggest := sortlist[i]
ELSIF sortlist[i] < littlest THEN littlest := sortlist[i]
END ;
INC(i)
END
END Initarr;
PROCEDURE Quicksort(VAR a: ARRAY OF LONGINT; l,r: LONGINT);
(* quicksort the array A from start to finish *)
VAR i,j,x,w: LONGINT;
BEGIN
i:=l; j:=r;
x:=a[(l+r) DIV 2D];
REPEAT
WHILE a[i]<x DO i := i+1D END;
WHILE x<a[j] DO j := j-1D END;
IF i<=j THEN
w := a[i];
a[i] := a[j];
a[j] := w;
i := i+1D; j := j-1D
END ;
UNTIL i > j;
IF l<j THEN Quicksort(a,l,j) END;
IF i<r THEN Quicksort(a,i,r) END
END Quicksort;
PROCEDURE Quick ();
BEGIN
Initarr();
Quicksort(sortlist,1,sortelements);
IF (sortlist[1] # littlest) OR (sortlist[sortelements] # biggest) THEN WriteString( " Error in Quick.$") END ;
END Quick;
(* Sorts an array using bubblesort *)
PROCEDURE bInitarr();
VAR i, temp: LONGINT;
BEGIN
Initrand();
biggest := 0; littlest := 0; i := 1D;
WHILE i <= LONG(srtelements) DO
temp := Rand();
sortlist[i] := temp - (temp DIV 100000D)*100000D - 50000D;
IF sortlist[i] > biggest THEN biggest := sortlist[i]
ELSIF sortlist[i] < littlest THEN littlest := sortlist[i]
END ;
INC(i)
END
END bInitarr;
PROCEDURE Bubble();
VAR i, j: LONGINT;
BEGIN
bInitarr();
top:=srtelements;
WHILE top>1D DO
i:=1D;
WHILE i<top DO
IF sortlist[i] > sortlist[i+1D] THEN
j := sortlist[i];
sortlist[i] := sortlist[i+1D];
sortlist[i+1D] := j;
END ;
i:=i+1D;
END;
top:=top-1D;
END;
IF (sortlist[1] # littlest) OR (sortlist[srtelements] # biggest) THEN WriteString("Error3 in Bubble.$") END ;
END Bubble;
(* Sorts an array using treesort *)
PROCEDURE tInitarr();
VAR i, temp: LONGINT;
BEGIN
Initrand();
biggest := 0; littlest := 0; i := 1D;
WHILE i <= LONG(sortelements) DO
temp := Rand();
sortlist[i] := temp - (temp DIV 100000D)*100000D - 50000D;
IF sortlist[i] > biggest THEN biggest := sortlist[i]
ELSIF sortlist[i] < littlest THEN littlest := sortlist[i]
END ;
INC(i)
END
END tInitarr;
PROCEDURE CreateNode (VAR t: node; n: LONGINT);
BEGIN
ALLOCATE(t, SIZE(nodeDesc));
t^.left := NIL; t^.right := NIL;
t^.val := n
END CreateNode;
PROCEDURE Insert(n: LONGINT; t: node);
(* insert n into tree *)
BEGIN
IF n > t^.val THEN
IF t^.left = NIL THEN CreateNode(t^.left,n)
ELSE Insert(n,t^.left)
END
ELSIF n < t^.val THEN
IF t^.right = NIL THEN CreateNode(t^.right,n)
ELSE Insert(n,t^.right)
END
END
END Insert;
PROCEDURE Checktree(p: node): BOOLEAN;
(* check by inorder traversal *)
VAR result: BOOLEAN;
BEGIN
result := TRUE;
IF p^.left # NIL THEN
IF p^.left^.val <= p^.val THEN result := FALSE;
ELSE result := Checktree(p^.left) & result
END
END ;
IF p^.right # NIL THEN
IF p^.right^.val >= p^.val THEN result := FALSE;
ELSE result := Checktree(p^.right) & result
END
END;
RETURN result
END Checktree;
PROCEDURE Trees();
VAR i: LONGINT;
BEGIN
tInitarr();
ALLOCATE(tree, TSIZE(nodeDesc));
tree^.left := NIL; tree^.right:=NIL; tree^.val:=sortlist[1];
i := 2D;
WHILE i <= LONG(sortelements) DO
Insert(sortlist[i],tree);
INC(i)
END;
IF ~ Checktree(tree) THEN WriteString(" Error in Tree.$") END;
END Trees;
PROCEDURE Time(s: ARRAY OF CHAR; p: Proc; base, fbase: REAL);
VAR timer: LONGINT;
BEGIN
timer := Getclock();
p;
timer := Getclock()-timer;
WriteString(s);
WriteInt(SHORT(timer), 8); WriteLn;
fixed := fixed + FLOAT(timer)*base;
floated := floated + FLOAT(timer)*fbase
END Time;
PROCEDURE main2(i: INTEGER);
BEGIN
fixed := 0.0; floated := 0.0;
Time("Puzzle ", Puzzle, puzzlebase, puzzlebase);
Time("Quick ", Quick, quickbase, quickbase);
Time("Bubble ", Bubble, bubblebase, bubblebase);
Time("Tree ", Trees, treebase, treebase);
END main2;
PROCEDURE main;
BEGIN
fixed := 0.0; floated := 0.0;
Time("Puzzle ", Puzzle, puzzlebase, puzzlebase);
Time("Quick ", Quick, quickbase, quickbase);
Time("Bubble ", Bubble, bubblebase, bubblebase);
Time("Tree ", Trees, treebase, treebase);
WriteLn;
main2(19);
END main;
BEGIN
OpenOutput("H3.Mac");
WriteString("Hennessy3 mit MacMETH 3.2 : "); WriteLn;
WriteLn;
main;
CloseOutput;
WriteLn;
WriteString("any key to terminate. "); WriteLn;
Read(ch);
END Hennessy3.